home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / SCHEME / GNU / SCM4E1 / !Scm / slib / object < prev    next >
Text File  |  1994-03-08  |  3KB  |  97 lines
  1. ;;; "object.scm" Macroless Object System
  2. ;;;From: whumeniu@datap.ca (Wade Humeniuk)
  3. ;;;Date:  February 15, 1994
  4.  
  5. ;; Object Construction:
  6. ;;       0           1          2             3              4
  7. ;; #(object-tag get-method make-method! unmake-method! get-all-methods)
  8.  
  9. (define object:tag "object")
  10.  
  11. ;;; This might be better done using COMLIST:DELETE-IF.
  12. (define (object:removeq obj alist)
  13.   (if (null? alist)
  14.       alist
  15.       (if (eq? (caar alist) obj)
  16.       (cdr alist)
  17.       (cons (car alist) (object:removeq obj (cdr alist))))))
  18.  
  19. (define (get-all-methods obj)
  20.   (if (object? obj)
  21.       ((vector-ref obj 4))
  22.       (error "Cannot get methods on non-object: " obj)))
  23.  
  24. (define (object? obj)
  25.   (and (vector? obj)
  26.        (eq? object:tag (vector-ref obj 0))))
  27.  
  28. (define (make-method! obj generic-method method)
  29.   (if (object? obj)
  30.       (if (procedure? method)
  31.       (begin
  32.         ((vector-ref obj 2) generic-method method)
  33.         method)
  34.       (error "Method must be a procedure: " method))
  35.       (error "Cannot make method on non-object: " obj)))
  36.   
  37. (define (get-method obj generic-method)
  38.   (if (object? obj)
  39.       ((vector-ref obj 1) generic-method)
  40.       (error "Cannot get method on non-object: " obj)))
  41.   
  42. (define (unmake-method! obj generic-method)
  43.   (if (object? obj)
  44.       ((vector-ref obj 3) generic-method)
  45.       (error "Cannot unmake method on non-object: " obj)))
  46.   
  47. (define (make-predicate! obj generic-predicate)
  48.   (if (object? obj)
  49.       ((vector-ref obj 2) generic-predicate (lambda (self) #t))
  50.       (error "Cannot make predicate on non-object: " obj)))
  51.  
  52. (define (make-generic-method . exception-procedure)
  53.   (define generic-method
  54.     (lambda (obj . operands)
  55.       (if (object? obj)
  56.       (let ((object-method ((vector-ref obj 1) generic-method)))
  57.         (if object-method
  58.         (apply object-method (cons obj operands))
  59.         (error "Method not supported: " obj)))
  60.       (apply exception-procedure (cons obj operands)))))
  61.   
  62.   (if (not (null? exception-procedure))
  63.       (if (procedure? (car exception-procedure))
  64.       (set! exception-procedure (car exception-procedure))
  65.       (error "Exception Handler Not Procedure:"))
  66.       (set! exception-procedure
  67.         (lambda (obj . params) 
  68.           (error "Operation not supported: " obj))))
  69.   generic-method)
  70.   
  71. (define (make-generic-predicate)
  72.   (define generic-predicate 
  73.     (lambda (obj)
  74.       (if (object? obj)
  75.       (if ((vector-ref obj 1) generic-predicate)
  76.           #t 
  77.           #f)
  78.       #f)))
  79.   generic-predicate)
  80.   
  81. (define (make-object . ancestors)
  82.   (define method-list 
  83.     (apply append (map (lambda (obj) (get-all-methods obj)) ancestors)))
  84.   (define (make-method! generic-method method)
  85.     (set! method-list (cons (cons generic-method method) method-list))
  86.     method)
  87.   (define (unmake-method! generic-method) 
  88.     (set! method-list (object:removeq generic-method method-list))
  89.     #t)
  90.   (define (all-methods) method-list)
  91.   (define (get-method generic-method)
  92.     (let ((method-def (assq generic-method method-list)))
  93.       (if method-def (cdr method-def) #f)))
  94.   (vector object:tag get-method make-method! unmake-method! all-methods))
  95.  
  96.  
  97.